//==============================================================================
// Author: Fabrizio Vita
// Date: 2011-01-13
// Copyright: (c)2010-2011 ItacaSoft di Vita Fabrizio. ALL RIGHTS RESERVED.
//===============================================================================
unit ConversionUtils;

interface

uses
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  Classes, ImageHlp, Variants, HttpApp;

type
  TLoadedImage = _LOADED_IMAGE;

function StrToBoolean(const S: string): Boolean;
function IntToBool(I: Integer): Boolean;
function BoolToInt(B: Boolean): Integer;
function GetModulePath: string;
function GetModuleName: string;
function StringToPAnsiChar(stringVar : string) : PAnsiChar;
function VariantToString(Value: Variant): String;
function XSDateTimeToNativeDateTime(value: string): TDateTime;
function NativeDateTimeToXSDateTime(value: TdateTime): string;
procedure StreamToVariant(const Stream: TStream; out V: OleVariant);
procedure VariantToStream(const V: OleVariant; const Stream: TStream);
function GetAbsoluteUri(request: TWebRequest; useHttps: boolean): string;
function CreateGuid: string;

implementation

uses sysutils,
{$IFNDEF IS_ISAPI}
   forms,
{$ENDIF}
XSBuiltIns, ISAPIHttp, ActiveX;

const
  DefaultTrueBoolStr  = 'True';  // DO NOT LOCALIZE
  DefaultFalseBoolStr = 'False'; // DO NOT LOCALIZE

  DefaultYesBoolStr   = 'Yes';   // DO NOT LOCALIZE
  DefaultNoBoolStr    = 'No';    // DO NOT LOCALIZE

function StrToBoolean(const S: string): Boolean;
var
  LowerCasedText: string;
begin
  { TODO : Possibility to add localized strings, like in Delphi 7 }
  { TODO : Lower case constants }
  LowerCasedText := LowerCase(S);
  Result := ((S = '1') or
    (LowerCasedText = LowerCase(DefaultTrueBoolStr)) or (LowerCasedText = LowerCase(DefaultYesBoolStr))) or
    (LowerCasedText = LowerCase(DefaultTrueBoolStr[1])) or (LowerCasedText = LowerCase(DefaultYesBoolStr[1]));
  if not Result then
  begin
    Result := not ((S = '0') or
      (LowerCasedText = LowerCase(DefaultFalseBoolStr)) or (LowerCasedText = LowerCase(DefaultNoBoolStr)) or
      (LowerCasedText = LowerCase(DefaultFalseBoolStr[1])) or (LowerCasedText = LowerCase(DefaultNoBoolStr[1])));
    if Result then
      raise Exception.Create('Error converting string to boolean');
  end;
end;

function IntToBool(I: Integer): Boolean;
begin
  Result := I <> 0;
end;

function BoolToInt(B: Boolean): Integer;
begin
  Result := Ord(B);
end;

///Restituisce il nome della dll corrente
function GetModuleName: string;
begin
   result := ExtractFileName(GetModulePath);
end;


///Restituisce il path completo di nome della dll corrente
function GetModulePath: string;
var
   DLLFileName: array[0..MAX_PATH] of Char;
   i: integer;
begin
{$IFDEF IS_ISAPI}
  {$IFDEF UNICODE}
     GetModuleFileNameW(hInstance, DLLFileName, MAX_PATH);
  {$ELSE}
     GetModuleFileName(hInstance, DLLFileName, MAX_PATH);
  {$ENDIF}
   result := string(DLLFileName);
{$ELSE}
   result := Application.ExeName;
{$ENDIF}

   i := Pos('\\?\', result);
   if i = 1 then
   begin
      result := copy(result, 5, length(result));
   end;

end;

function LinkerTimeStamp(const FileName: string): TDateTime;
var
  LI: TLoadedImage;
begin
{$WARNINGS OFF}
  {$IFDEF UNICODE}
  Win32Check(MapAndLoad(PAnsiChar(AnsiString(FileName)), nil, @LI, False, True));
  {$ELSE}
  Win32Check(MapAndLoad(PChar(FileName), nil, @LI, False, True));
  {$ENDIF}
{$WARNINGS ON}
  Result := LI.FileHeader.FileHeader.TimeDateStamp / SecsPerDay + UnixDateDelta;
  UnMapAndLoad(@LI);
end;


function StringToPAnsiChar(stringVar : string) : PAnsiChar;
Var
  AnsString : AnsiString;
  InternalError : Boolean;
begin
  InternalError := false;
  Result := '';
  try
    if stringVar <> '' Then
    begin
       AnsString := AnsiString(StringVar);
       Result := PAnsiChar(PAnsiString(AnsString));
    end;
  Except
    InternalError := true;
  end;
  if InternalError or (String(Result) <> stringVar) then
  begin
    Raise Exception.Create('Conversion from string to PAnsiChar failed!');
  end;
end;

function VariantToString(Value: Variant): String;
var
   f: TFormatSettings;
begin
   if VarIsNull(Value) then
   begin
    result := '';
    exit;
   end;

   f.DecimalSeparator := '.';


   case TVarData(Value).VType of
      varShortInt,
      varByte,
      varWord,
      varLongWord,
      varInt64,
      varUInt64,
      varSmallInt,
      varInteger   : Result := IntToStr(Value);
       varSingle,
      varDouble,
      varCurrency  : Result := FloatToStr(Value, f);
      varDate      : Result := FormatDateTime('dd/mm/yyyy', Value);
      varBoolean   : if Value then Result := 'true' else Result := 'false';
      varString, varUString : Result := Value;
    else           Result := '';
  end;
end;


procedure StreamToVariant(const Stream: TStream; out V: OleVariant);
var
  P: Pointer;
begin
  V := VarArrayCreate([0, Stream.Size - 1], varByte);
  Stream.Position := 0;

  P := VarArrayLock(V);
  try
    Stream.Read(P^, Stream.Size);
  finally
    VarArrayUnlock(V);
  end;
end;

procedure VariantToStream(const V: OleVariant; const Stream: TStream);
var
  P: Pointer;
  L: Integer;
begin
  Assert(VarType(V) = varByte or varArray);
  Assert(VarArrayDimCount(V) = 1);

  L := VarArrayHighBound(V, 1) - VarArrayLowBound(V, 1) + 1;
  Stream.Size := L;
  Stream.Position := 0;

  P := VarArrayLock(V);
  try
    Stream.Write(P^, Stream.Size);
  finally
    VarArrayUnlock(V);
  end;
end;

{ Converte una data dal formato XML al formato Delphi  }
function XSDateTimeToNativeDateTime(value: string): TDateTime;
var
   tx : TXSDateTime;
begin
   tx := TXSDateTime.Create();
   tx.XSToNative(value);
   result := tx.AsDateTime;
   tx.Free;
end;

{ Converte una data dal formato Delphi al formato XML }
function NativeDateTimeToXSDateTime(value: TdateTime): string;
var
   tx : TXSDateTime;
begin
   tx := TXSDateTime.Create();
   tx.AsDateTime := value;
   result := tx.NativeToXS;//  '0001-01-01T00:00:00';// FormatDateTime('dd-mm-yyyy', Now);
   tx.Free;
end;


function GetAbsoluteUri(Request: TWebRequest; useHttps: boolean): String;
var
   str: string;
   i: integer;
begin
   {
   str := request.GetFieldByName('SERVER_PROTOCOL');
   str := request.GetFieldByName('URL');
   str := request.GetFieldByName('');
   str := request.GetFieldByName( 'HTTP_CACHE_CONTROL');
   str := request.GetFieldByName(    'HTTP_DATE');
   str := request.GetFieldByName(    'HTTP_ACCEPT');
   str := request.GetFieldByName(    'HTTP_FROM');
   str := request.GetFieldByName(    'HTTP_HOST');
   str := request.GetFieldByName(    'HTTP_IF_MODIFIED_SINCE');
   str := request.GetFieldByName(    'HTTP_REFERER');
   str := request.GetFieldByName(    'HTTP_USER_AGENT');
   str := request.GetFieldByName(    'HTTP_CONTENT_ENCODING');
   str := request.GetFieldByName(    'CONTENT_TYPE');
   str := request.GetFieldByName(    'CONTENT_LENGTH');
   str := request.GetFieldByName(    'HTTP_CONTENT_VERSION');
   str := request.GetFieldByName(    'HTTP_DERIVED_FROM');
   str := request.GetFieldByName(    'HTTP_EXPIRES');
   str := request.GetFieldByName(    'HTTP_TITLE');
   str := request.GetFieldByName(    'REMOTE_ADDR');
   str := request.GetFieldByName(    'REMOTE_HOST');
   str := request.GetFieldByName(    'SCRIPT_NAME');
   str := request.GetFieldByName(    'SERVER_PORT');
   str := request.GetFieldByName(    'HTTP_CONNECTION');
   str := request.GetFieldByName(    'HTTP_COOKIE');
   str := request.GetFieldByName(    'HTTP_AUTHORIZATION');
   }

  { Here we set the proper url prefix and port [if nessecary] }
  if usehttps then begin // SSL
    if (Request.ServerPort <> 443) and (Pos(':', Request.Host) = 0) then
      Result := 'https://' + Request.Host + ':' + IntToStr(Request.ServerPort) + Request.InternalScriptName         { do not localize }
    else
      Result := 'https://' + Request.Host + Request.InternalScriptName;    { do not localize }
  end else begin                                            // Normal
    if (Request.ServerPort <> 80) and (Pos(':', Request.Host) = 0) then
      Result := 'http://' + Request.Host + ':' + IntToStr(Request.ServerPort) + Request.InternalScriptName         { do not localize }
    else
      Result := 'http://' + Request.Host + Request.InternalScriptName;    { do not localize }
  end;
end;

function CreateGuid: string;
var
  ID: TGUID;
begin
  Result := '';
  if CoCreateGuid(ID) = S_OK then
    Result := GUIDToString(ID);
end;


end.
